VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ConBaseDatos"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'para ejecutar un procedimiento almacenado con parametros
'y asignarlo a un recordset
'Coneccion.NombreSP Parametros,RecordSet donde se asignan los datos
'con.Coneccion.sp_aranceles "0000000001,i", con.Registros
'con.Coneccion.sp_aranceles "", con.Registros

Private con As New ADODB.Connection, rec As New ADODB.Recordset

Public Enum TipoRecordSet
    Consulta = 1
    Tabla = 2
End Enum

Public Enum TipoDato
    Texto = 1
    fecha = 1
    Logico = 2
    Numerico = 2
End Enum

Private Sub Class_Initialize()
'inicializo la clase

On Error GoTo Errores

If con.State = adStateClosed Then
    con.CursorLocation = adUseClient
    con.CommandTimeout = TimeOut
    'con.Open GetConnectionString
    Set con = Conexion.Coneccion
End If

Exit Sub

Errores:
    MsgBox "Error al conectar con servidor de datos" + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Sub

Private Sub Class_Terminate()
'cierro la clase

On Error GoTo Errores

'If con.State <> adStateClosed Then con.Close
Set con = Nothing

Exit Sub

Errores:
    MsgBox "Error al cerrar coneccion con servidor de datos" + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Sub

Public Sub AbrirRegistros(strConsulta As String, Tipo As TipoRecordSet)
'abre un conjunto de registros

On Error Resume Next
rec.Close
Set rec = Nothing

On Error GoTo Errores

rec.CursorLocation = adUseClient
rec.Open strConsulta, con, adOpenDynamic, adLockOptimistic, Tipo

Exit Sub

Errores:
    MsgBox "Error al abrir registro: " + strConsulta + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Sub

Public Sub CerrarRegistros()
'cierro los registros abiertos

On Error GoTo Errores

rec.Close
Set rec = Nothing

Exit Sub

Errores:
    MsgBox "Error al cerrar recordset" + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Sub

Public Property Get Registros() As ADODB.Recordset
'devuelvo el recordset

On Error GoTo Errores

Set Registros = rec

Exit Property

Errores:
    MsgBox "Error regisrto" + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Property

Public Property Let Registros(ByVal cRecordset As ADODB.Recordset)
'asigno al recordset

On Error GoTo Errores

Set rec = cRecordset

Exit Property

Errores:
    MsgBox "Error regisrto" + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Property

Public Property Get Coneccion() As ADODB.Connection
'devuelvo la coneccion

On Error GoTo Errores

Set Coneccion = con

Exit Property

Errores:
    MsgBox "Error coneccion" + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Property

Public Sub Ejecutar(Texto As String)
'ejecuto una consulta sql

On Error GoTo Errores

con.BeginTrans

con.Execute Texto

con.CommitTrans

Exit Sub

Errores:
    con.RollbackTrans
    MsgBox "Error al ejecutar, txt" + Texto + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Sub

Public Sub InsertarRegistros(Tabla As String, Campos As String, datos As String)
'inserto un registro

On Error GoTo Errores

Dim txt As String, txtlog As String

txt = "insert into " & Tabla & "(" & Campos & ") values(" & datos & ")"

'log del sistema
txtlog = "insert into sistema_log(usuario,accion,tabla,fecha,descripcion) values('" & IDUsuario & "','nuevo','" & Tabla & "','" & Fecha_Server & "','" & Replace(txt, "'", """") & "')"

con.BeginTrans

con.Execute txt

con.Execute txtlog

con.CommitTrans

Exit Sub

Errores:
    con.RollbackTrans
    MsgBox "Error al insertar Registros: " & Err.Description & vbCrLf & txt & vbCrLf & txtlog, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Sub

Public Sub ActualizarRegistros(Tabla As String, Campos As String, datos As String, Condicion As String)
'actualizo un registro

On Error GoTo Errores

Dim mcampos, mdatos, i As Integer, txt As String, txt2 As String, txtlog As String

mcampos = Split(Campos, ",")
mdatos = Split(datos, ",")

txt = ""

For i = 0 To UBound(mcampos)
 txt = txt & mcampos(i) & "=" & mdatos(i) & ","
Next
txt = Mid(txt, 1, Len(txt) - 1)

txt2 = "update " & Tabla & " set " & txt & " where " & Condicion

'log del sistema
txtlog = "insert into sistema_log(usuario,accion,tabla,fecha,descripcion) values('" & IDUsuario & "','modificar','" & Tabla & "','" & Fecha_Server & "','" & BusInfRegistro(Tabla, Condicion) & " --- " & Replace(txt2, "'", """") & "')"

con.BeginTrans

con.Execute txt2

con.Execute txtlog

con.CommitTrans

Exit Sub

Errores:
    con.RollbackTrans
    MsgBox "Error al modificar Registro: " & Err.Description & vbCrLf & txt2 & vbCrLf & txtlog, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Sub

Public Sub BorrarRegistros(Tabla As String, Condicion As String)
'borro un registro

On Error GoTo Errores

Dim txt As String, txtlog As String

txt = "delete " & Tabla & " where " & Condicion

'log del sistema
txtlog = "insert into sistema_log(usuario,accion,tabla,fecha,descripcion) values('" & IDUsuario & "','borrar','" & Tabla & "','" & Fecha_Server & "','" & BusInfRegistro(Tabla, Condicion) & " --- " & Replace(txt, "'", """") & "')"

con.BeginTrans

con.Execute txt

con.Execute txtlog

con.CommitTrans

Exit Sub

Errores:
    con.RollbackTrans
    MsgBox "Error al borrar registros: " & Err.Description & vbCrLf & txt & vbCrLf & txtlog, vbCritical, "Error"
    Err.Clear
    On Error GoTo 0

End Sub

Public Function BusProximoID(Tabla As String, Campo As String) As String
'busco el proximo id de un campo en una tabla

On Error GoTo Errores

Dim rc As New ADODB.Recordset

Set rc = con.Execute("select replicate('0'," & LargoID & "-len(isnull(max(" & Campo & "),0)+1)) + convert(varchar,isnull(max(" & Campo & "),0)+1) as numid from " & Tabla)

BusProximoID = rc("numid")

rc.Close
Set rc = Nothing

Exit Function

Errores:
    MsgBox "Error al buscar proximo ID en tabla: " + Tabla + " y campo: " + Campo + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    Set rc = Nothing
    On Error GoTo 0

End Function

Public Function ExisteDato(Tabla As String, Campo As String, dato As String, Tipo As TipoDato) As Boolean
'busca si existe un dato, si lo encuentra devuelve true si no false

On Error GoTo Errores

Dim ctxt As String, rc As New ADODB.Recordset

If Tipo = 1 Then ctxt = "'"

Set rc = con.Execute("select * from " & Trim(Tabla) & " where " & Trim(Campo) & "=" & ctxt & Trim(dato) & ctxt)
If Not rc.EOF Then
 ExisteDato = True
Else
 ExisteDato = False
End If
rc.Close
Set rc = Nothing

Exit Function

Errores:
    MsgBox "Error al buscar dato en tabla: " + Tabla + ", campo: " + Campo + " y dato: " + dato + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    Set rc = Nothing
    On Error GoTo 0

End Function

Public Function ExisteDatos(Tabla As String, Where As String) As Boolean
'busca si existe un dato con un where, si lo encuentra devuelve true si no false

On Error GoTo Errores

Dim rc As New ADODB.Recordset

Set rc = con.Execute("select * from " & Trim(Tabla) & " where " & Trim(Where))
If Not rc.EOF Then
 ExisteDatos = True
Else
 ExisteDatos = False
End If
rc.Close
Set rc = Nothing

Exit Function

Errores:
    MsgBox "Error al buscar dato en tabla: " + Tabla + " con where: " + Where + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    Set rc = Nothing
    On Error GoTo 0

End Function

Public Function BusDato(Tabla As String, Campo As String, Where As String) As Variant
'busca un dato, si lo encuentra devuelve el dato sino nada

On Error GoTo Errores

Dim rc As New ADODB.Recordset

If Where = "" Then
 Set rc = con.Execute("select " & Trim(Campo) & " from " & Trim(Tabla))
Else
 Set rc = con.Execute("select " & Trim(Campo) & " from " & Trim(Tabla) & " where " & Trim(Where))
End If
If Not rc.EOF Then
 BusDato = rc(0)
Else
 BusDato = ""
End If
rc.Close
Set rc = Nothing

Exit Function

Errores:
    MsgBox "Error al buscar dato en tabla: " + Tabla + ",con campo: " + Campo + " y con where: " + Where + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    Set rc = Nothing
    On Error GoTo 0

End Function

Public Function BusPrimerDato(Tabla As String, Campo As String) As Variant
'busca el primer dato en una tabla

On Error GoTo Errores

Dim rc As New ADODB.Recordset

Set rc = con.Execute("select top 1 " & Trim(Campo) & " from " & Trim(Tabla) & " order by 1 asc")
If Not rc.EOF Then
 BusPrimerDato = rc(0)
Else
 BusPrimerDato = ""
End If
rc.Close
Set rc = Nothing

Exit Function

Errores:
    MsgBox "Error al buscar primer dato en tabla: " + Tabla + " y campo: " + Campo + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    Set rc = Nothing
    On Error GoTo 0

End Function

Public Function BusUltimoDato(Tabla As String, Campo As String) As Variant
'busca el ultimo dato en una tabla

On Error GoTo Errores

Dim rc As New ADODB.Recordset

Set rc = con.Execute("select top 1 " & Trim(Campo) & " from " & Trim(Tabla) & " order by 1 desc")
If Not rc.EOF Then
 BusUltimoDato = rc(0)
Else
 BusUltimoDato = ""
End If
rc.Close
Set rc = Nothing

Exit Function

Errores:
    MsgBox "Error al buscar ultimo dato en tabla: " + Tabla + " y campo: " + Campo + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    Set rc = Nothing
    On Error GoTo 0

End Function

Public Function BusInfRegistro(Tabla As String, Where As String) As String
'busca un registro y devuelve todo el contenido del mismo en un string

On Error GoTo Errores

Dim rc As New ADODB.Recordset, txt As String, i As Integer

Set rc = con.Execute("select * from " & Trim(Tabla) & " where " & Where)
txt = ""
Do While Not rc.EOF
    For i = 0 To rc.Fields.Count - 1
        txt = txt & rc(i).Name & "=" & rc(i) & ", "
    Next i
    txt = Mid(txt, 1, InStrRev(txt, ",") - 1) & " | "
    rc.MoveNext
    DoEvents
Loop
rc.Close
Set rc = Nothing

If Len(txt) < 2 Then Exit Function
BusInfRegistro = Mid(txt, 1, InStrRev(txt, "|") - 2)

Exit Function

Errores:
    MsgBox "Error al buscar informacion de registro en tabla: " + Tabla + " con where " + Where + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    Set rc = Nothing
    On Error GoTo 0

End Function

Public Function CantidadRegistros(Tabla As String) As Double
'devuelve la cantidad de registros de una tabla

On Error GoTo Errores

Dim rc As New ADODB.Recordset

Set rc = con.Execute("select count(*) from " & Trim(Tabla))

CantidadRegistros = rc(0)

rc.Close
Set rc = Nothing

Exit Function

Errores:
    MsgBox "Error al buscar cantidad de registros en tabla: " + Tabla + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    Set rc = Nothing
    On Error GoTo 0

End Function

Public Function SPpRetornaRS(Procedimiento As String, Parametros As Variant) As ADODB.Recordset

'ejecuta un procedimiento almacenado con parametros y devuelve
'un recordset

On Error GoTo Errores

Dim Cmd As New ADODB.Command, rc As New ADODB.Recordset

With Cmd
    .ActiveConnection = con
    .CommandText = Procedimiento
    .CommandType = adCmdStoredProc

    'Ejucuta la consulta para Read Only
    rc.CursorLocation = adUseClient
    rc.CursorType = adOpenForwardOnly
    rc.LockType = adLockReadOnly
    
    Set rc = .Execute(, Parametros)
End With

Set SPpRetornaRS = rc

'Destruyo las conexiones
Set Cmd.ActiveConnection = Nothing
Set Cmd = Nothing
Set rc = Nothing
Exit Function

Errores:
    MsgBox "Error al ejecutar procedimiento con parametro: " + Procedimiento + vbCrLf + Err.Description, vbCritical, "Error"
    Err.Clear
    Set rc = Nothing
    On Error GoTo 0
    
End Function

Public Property Get DataSource() As DataSource

End Property

Public Property Set DataSource(ByVal objDataSource As DataSource)

End Property

Public Property Get DataMember() As DataMember

End Property

Public Property Let DataMember(ByVal DataMember As DataMember)

End Property
